home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tcl / dist6.3 / tests / info.test < prev    next >
Encoding:
Text File  |  1991-09-23  |  11.0 KB  |  376 lines
  1. # Commands covered:  info
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright 1991 Regents of the University of California
  8. # Permission to use, copy, modify, and distribute this
  9. # software and its documentation for any purpose and without
  10. # fee is hereby granted, provided that this copyright notice
  11. # appears in all copies.  The University of California makes no
  12. # representations about the suitability of this software for any
  13. # purpose.  It is provided "as is" without express or implied
  14. # warranty.
  15. #
  16. # $Header: /sprite/src/lib/tcl/tests/RCS/info.test,v 1.10 91/09/23 13:06:05 ouster Exp $ (Berkeley)
  17.  
  18. if {[string compare test [info procs test]] == 1} then {source defs}
  19.  
  20. test info-1.1 {info args option} {
  21.     proc t1 {a bbb c} {return foo}
  22.     info args t1
  23. } {a bbb c}
  24. test info-1.2 {info args option} {
  25.     proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
  26.     info a t1
  27. } {a bbb c args}
  28. test info-1.3 {info args option} {
  29.     proc t1 "" {return foo}
  30.     info args t1
  31. } {}
  32. test info-1.4 {info args option} {
  33.     catch {rename t1 {}}
  34.     list [catch {info args t1} msg] $msg
  35. } {1 {"t1" isn't a procedure}}
  36. test info-1.5 {info args option} {
  37.     list [catch {info args set} msg] $msg
  38. } {1 {"set" isn't a procedure}}
  39.  
  40. test info-2.1 {info body option} {
  41.     proc t1 {} {body of t1}
  42.     info body t1
  43. } {body of t1}
  44. test info-2.2 {info body option} {
  45.     list [catch {info body set} msg] $msg
  46. } {1 {"set" isn't a procedure}}
  47. test info-2.3 {info body option} {
  48.     list [catch {info args set 1} msg] $msg
  49. } {1 {wrong # args: should be "info args procname"}}
  50.  
  51. test info-3.1 {info cmdcount option} {
  52.     set x [info cmdcount]
  53.     set y 12345
  54.     set z [info cm]
  55.     expr $z-$x
  56. } 3
  57. test info-3.2 {info body option} {
  58.     list [catch {info cmdcount 1} msg] $msg
  59. } {1 {wrong # args: should be "info cmdcount"}}
  60.  
  61. test info-4.1 {info commands option} {
  62.     proc t1 {} {}
  63.     proc t2 {} {}
  64.     set x " [info commands] "
  65.     list [string match {* t1 *} $x] [string match {* t2 *} $x] \
  66.             [string match {* set *} $x] [string match {* list *} $x]
  67. } {1 1 1 1}
  68. test info-4.2 {info commands option} {
  69.     proc t1 {} {}
  70.     rename t1 {}
  71.     set x [info co]
  72.     string match {* t1 *} $x
  73. } 0
  74. test info-4.3 {info commands option} {
  75.     proc _t1_ {} {}
  76.     proc _t2_ {} {}
  77.     info commands _t1_
  78. } _t1_
  79. test info-4.4 {info commands option} {
  80.     proc _t1_ {} {}
  81.     proc _t2_ {} {}
  82.     lsort [info commands _t*]
  83. } {_t1_ _t2_}
  84. catch {rename _t1_ {}}
  85. catch {rename _t2_ {}}
  86. test info-4.5 {info commands option} {
  87.     list [catch {info commands a b} msg] $msg
  88. } {1 {wrong # args: should be "info commands [pattern]"}}
  89.  
  90. test info-5.1 {info default option} {
  91.     proc t1 {a b {c d} {e "long default value"}} {}
  92.     info default t1 a value
  93. } 0
  94. test info-5.2 {info default option} {
  95.     proc t1 {a b {c d} {e "long default value"}} {}
  96.     set value 12345
  97.     info d t1 a value
  98.     set value
  99. } {}
  100. test info-5.3 {info default option} {
  101.     proc t1 {a b {c d} {e "long default value"}} {}
  102.     info default t1 c value
  103. } 1
  104. test info-5.4 {info default option} {
  105.     proc t1 {a b {c d} {e "long default value"}} {}
  106.     set value 12345
  107.     info default t1 c value
  108.     set value
  109. } d
  110. test info-5.5 {info default option} {
  111.     proc t1 {a b {c d} {e "long default value"}} {}
  112.     set value 12345
  113.     set x [info default t1 e value]
  114.     list $x $value
  115. } {1 {long default value}}
  116. test info-5.6 {info default option} {
  117.     list [catch {info default a b} msg] $msg
  118. } {1 {wrong # args: should be "info default procname arg varname"}}
  119. test info-5.7 {info default option} {
  120.     list [catch {info default _nonexistent_ a b} msg] $msg
  121. } {1 {"_nonexistent_" isn't a procedure}}
  122. test info-5.8 {info default option} {
  123.     proc t1 {a b} {}
  124.     list [catch {info default t1 x value} msg] $msg
  125. } {1 {procedure "t1" doesn't have an argument "x"}}
  126. test info-5.9 {info default option} {
  127.     catch {unset a}
  128.     set a(0) 88
  129.     proc t1 {a b} {}
  130.     list [catch {info default t1 a a} msg] $msg
  131. } {1 {couldn't store default value in variable "a"}}
  132. test info-5.10 {info default option} {
  133.     catch {unset a}
  134.     set a(0) 88
  135.     proc t1 {{a 18} b} {}
  136.     list [catch {info default t1 a a} msg] $msg
  137. } {1 {couldn't store default value in variable "a"}}
  138. catch {unset a}
  139.  
  140. test info-6.1 {info exists option} {
  141.     set value foo
  142.     info exists value
  143. } 1
  144. catch {unset _nonexistent_}
  145. test info-6.2 {info exists option} {
  146.     info exists _nonexistent_
  147. } 0
  148. test info-6.3 {info exists option} {
  149.     proc t1 {x} {return [info exists x]}
  150.     t1 2
  151. } 1
  152. test info-6.4 {info exists option} {
  153.     proc t1 {x} {
  154.         global _nonexistent_
  155.         return [info exists _nonexistent_]
  156.     }
  157.     t1 2
  158. } 0
  159. test info-6.5 {info exists option} {
  160.     proc t1 {x} {
  161.         set y 47
  162.         return [info exists y]
  163.     }
  164.     t1 2
  165. } 1
  166. test info-6.6 {info exists option} {
  167.     proc t1 {x} {return [info exists value]}
  168.     t1 2
  169. } 0
  170. test info-6.7 {info exists option} {
  171.     catch {unset x}
  172.     set x(2) 44
  173.     list [info exists x] [info exists x(1)] [info exists x(2)]
  174. } {1 0 1}
  175. catch {unset x}
  176. test info-6.8 {info exists option} {
  177.     list [catch {info exists} msg] $msg
  178. } {1 {wrong # args: should be "info exists varName"}}
  179. test info-6.9 {info exists option} {
  180.     list [catch {info exists 1 2} msg] $msg
  181. } {1 {wrong # args: should be "info exists varName"}}
  182.  
  183. test info-7.1 {info globals option} {
  184.     set x 1
  185.     set y 2
  186.     set value 23
  187.     set a " [info globals] "
  188.     list [string match {* x *} $a] [string match {* y *} $a] \
  189.             [string match {* value *} $a] [string match {* _foobar_ *} $a]
  190. } {1 1 1 0}
  191. test info-7.2 {info globals option} {
  192.     set _xxx1 1
  193.     set _xxx2 2
  194.     lsort [info g _xxx*]
  195. } {_xxx1 _xxx2}
  196. test info-7.3 {info globals option} {
  197.     list [catch {info globals 1 2} msg] $msg
  198. } {1 {wrong # args: should be "info globals [pattern]"}}
  199.  
  200. test info-8.1 {info level option} {
  201.     info level
  202. } 0
  203. test info-8.2 {info level option} {
  204.     proc t1 {a b} {
  205.         set x [info le]
  206.         set y [info level 1]
  207.         list $x $y
  208.     }
  209.     t1 146 testString
  210. } {1 {t1 146 testString}}
  211. test info-8.3 {info level option} {
  212.     proc t1 {a b} {
  213.         t2 [expr $a*2] $b
  214.     }
  215.     proc t2 {x y} {
  216.         list [info level] [info level 1] [info level 2] [info level -1] \
  217.                 [info level 0]
  218.     }
  219.     t1 146 {a {b c} {{{c}}}}
  220. } {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
  221. test info-8.4 {info level option} {
  222.     proc t1 {} {
  223.         set x [info level]
  224.         set y [info level 1]
  225.         list $x $y
  226.     }
  227.     t1
  228. } {1 t1}
  229. test info-8.5 {info level option} {
  230.     list [catch {info level 1 2} msg] $msg
  231. } {1 {wrong # args: should be "info level [number]"}}
  232. test info-8.6 {info level option} {
  233.     list [catch {info level 123a} msg] $msg
  234. } {1 {expected integer but got "123a"}}
  235. test info-8.7 {info level option} {
  236.     list [catch {info level 0} msg] $msg
  237. } {1 {bad level "0"}}
  238. test info-8.8 {info level option} {
  239.     proc t1 {} {info level -1}
  240.     list [catch {t1} msg] $msg
  241. } {1 {bad level "-1"}}
  242. test info-8.9 {info level option} {
  243.     proc t1 {x} {info level $x}
  244.     list [catch {t1 -3} msg] $msg
  245. } {1 {bad level "-3"}}
  246.  
  247. test info-9.1 {info library option} {
  248.     list [catch {info library x} msg] $msg
  249. } {1 {wrong # args: should be "info library"}}
  250.  
  251. # The following check can only be done at Berkeley, where the exact
  252. # location of the library is known.
  253.  
  254. if {[glob ~] == "/users/ouster"} {
  255.     test info-9.2 {info library option} {
  256.     info li
  257.     } /sprite/lib/tcl
  258. }
  259.  
  260. test info-10.1 {info locals option} {
  261.     set a 22
  262.     proc t1 {x y} {
  263.         set b 13
  264.         set c testing
  265.         global a
  266.         return [info locals]
  267.     }
  268.     lsort [t1 23 24]
  269. } {b c x y}
  270. test info-10.2 {info locals option} {
  271.     proc t1 {x y} {
  272.         set xx1 2
  273.         set xx2 3
  274.         set y 4
  275.         return [info lo x*]
  276.     }
  277.     lsort [t1 2 3]
  278. } {x xx1 xx2}
  279. test info-10.3 {info locals option} {
  280.     list [catch {info locals 1 2} msg] $msg
  281. } {1 {wrong # args: should be "info locals [pattern]"}}
  282. test info-10.4 {info locals option} {
  283.     info locals
  284. } {}
  285. test info-10.5 {info locals option} {
  286.     proc t1 {} {return [info locals]}
  287.     t1
  288. } {}
  289.  
  290. test info-11.1 {info procs option} {
  291.     proc t1 {} {}
  292.     proc t2 {} {}
  293.     set x " [info procs] "
  294.     list [string match {* t1 *} $x] [string match {* t2 *} $x] \
  295.             [string match {* _undefined_ *} $x]
  296. } {1 1 0}
  297. test info-11.2 {info procs option} {
  298.     proc _tt1 {} {}
  299.     proc _tt2 {} {}
  300.     lsort [info p _tt*]
  301. } {_tt1 _tt2}
  302. catch {rename _tt1 {}}
  303. catch {rename _tt2 {}}
  304. test info-11.3 {info procs option} {
  305.     list [catch {info procs 2 3} msg] $msg
  306. } {1 {wrong # args: should be "info procs [pattern]"}}
  307.  
  308. test info-12.1 {info script option} {
  309.     list [catch {info script x} msg] $msg
  310. } {1 {wrong # args: should be "info script"}}
  311. test info-12.2 {info script option} {
  312.     file tail [info s]
  313. } info.test
  314. catch {exec rm -f gorp.info}
  315. exec cat > gorp.info << "info script\n"
  316. test info-12.3 {info script option} {
  317.     list [source gorp.info] [file tail [info script]]
  318. } {gorp.info info.test}
  319. test info-12.4 {resetting "info script" after errors} {
  320.     catch {source ~_nobody_/foo}
  321.     file tail [info script]
  322. } {info.test}
  323. test info-12.5 {resetting "info script" after errors} {
  324.     catch {source _nonexistent_}
  325.     file tail [info script]
  326. } {info.test}
  327. exec rm -f gorp.info
  328.  
  329. test info-13.1 {info tclversion option} {
  330.     set x [info tclversion]
  331.     scan $x "%d.%d%c" a b c
  332. } 2
  333. test info-13.2 {info tclversion option} {
  334.     list [catch {info t 2} msg] $msg
  335. } {1 {wrong # args: should be "info tclversion"}}
  336.  
  337. test info-14.1 {info vars option} {
  338.     set a 1
  339.     set b 2
  340.     proc t1 {x y} {
  341.         global a b
  342.         set c 33
  343.         return [info vars]
  344.     }
  345.     lsort [t1 18 19]
  346. } {a b c x y}
  347. test info-14.2 {info vars option} {
  348.     set xxx1 1
  349.     set xxx2 2
  350.     proc t1 {xxa y} {
  351.         global xxx1 xxx2
  352.         set c 33
  353.         return [info vars x*]
  354.     }
  355.     lsort [t1 18 19]
  356. } {xxa xxx1 xxx2}
  357. test info-14.3 {info vars option} {
  358.     lsort [info vars]
  359. } [lsort [info globals]]
  360. test info-14.4 {info vars option} {
  361.     list [catch {info vars a b} msg] $msg
  362. } {1 {wrong # args: should be "info vars [pattern]"}}
  363.  
  364. test info-15.1 {miscellaneous error conditions} {
  365.     list [catch {info} msg] $msg
  366. } {1 {wrong # args: should be "info option ?arg arg ...?"}}
  367. test info-15.2 {miscellaneous error conditions} {
  368.     list [catch {info gorp} msg] $msg
  369. } {1 {bad option "gorp": should be args, body, commands, cmdcount, default, exists, globals, level, library, locals, procs, script, tclversion, or vars}}
  370. test info-15.3 {miscellaneous error conditions} {
  371.     list [catch {info c} msg] $msg
  372. } {1 {bad option "c": should be args, body, commands, cmdcount, default, exists, globals, level, library, locals, procs, script, tclversion, or vars}}
  373. test info-15.4 {miscellaneous error conditions} {
  374.     list [catch {info l} msg] $msg
  375. } {1 {bad option "l": should be args, body, commands, cmdcount, default, exists, globals, level, library, locals, procs, script, tclversion, or vars}}
  376.